home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / support / format.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  24.5 KB  |  684 lines  |  [TEXT/CCL2]
  1. ;;; format.scm -- format function for Scheme
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  29 Oct 1991
  5. ;;;
  6. ;;;
  7. ;;; This code is adapted from the XP pretty printer originally written
  8. ;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
  9. ;;; to the original XP source file:
  10. ;;;
  11. ;;;------------------------------------------------------------------------
  12. ;;;
  13. ;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
  14. ;;; Cambridge, Massachusetts.
  15. ;;; 
  16. ;;; Permission to use, copy, modify, and distribute this software and its
  17. ;;; documentation for any purpose and without fee is hereby granted,
  18. ;;; provided that this copyright and permission notice appear in all
  19. ;;; copies and supporting documentation, and that the name of M.I.T. not
  20. ;;; be used in advertising or publicity pertaining to distribution of the
  21. ;;; software without specific, written prior permission. M.I.T. makes no
  22. ;;; representations about the suitability of this software for any
  23. ;;; purpose.  It is provided "as is" without express or implied warranty.
  24. ;;; 
  25. ;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  26. ;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  27. ;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  28. ;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  29. ;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  30. ;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  31. ;;;  SOFTWARE.
  32. ;;;
  33. ;;;------------------------------------------------------------------------
  34. ;;;
  35.  
  36.  
  37. ;;; The stream argument can be #f, in which case a string is returned.
  38. ;;; If the stream is #t, (current-output-port) is used.
  39. ;;; We compile a string argument into a function and call the function.
  40. ;;; The only exception is if the string doesn't contain any ~ escapes;
  41. ;;; then we can treat it as a literal and just write it to the stream.
  42.  
  43. (define (format stream string-or-fn . args)
  44.   (cond ((not stream)
  45.      (call-with-output-string
  46.          (lambda (stream)
  47.            (apply (function format) stream string-or-fn args))))
  48.     (else
  49.      (if (eq? stream '#t)
  50.          (setf stream (current-output-port)))
  51.      (when (string? string-or-fn)
  52.        (setf string-or-fn (xp.process-format-string string-or-fn)))
  53.      (if (string? string-or-fn)
  54.          (write-string string-or-fn stream)
  55.          (xp.maybe-initiate-xp-printing string-or-fn stream args))
  56.      '#f)))
  57.  
  58. (define xp.format-string-cache (make-table))
  59.  
  60. (define (xp.process-format-string string-or-fn)
  61.   (cond ((not (string? string-or-fn)) string-or-fn)
  62.     ((not xp.format-string-cache)
  63.      (xp.maybe-compile-format-string string-or-fn))
  64.     (else
  65.      (when (not (table? xp.format-string-cache))
  66.        (setf xp.format-string-cache (make-table)))
  67.      (let ((value
  68.            (table-entry xp.format-string-cache string-or-fn)))
  69.        (when (not value)
  70.          (setf value (xp.maybe-compile-format-string string-or-fn))
  71.          (setf (table-entry xp.format-string-cache string-or-fn)
  72.            value))
  73.        value))))
  74.  
  75.  
  76. (define (xp.maybe-compile-format-string string)
  77.   (let ((length  (string-length string)))
  78.     (or (xp.simple-format-string? string 0 length)
  79.     (let ((fn  (xp.parse-format-string string 0 length)))
  80.       (lambda (xp args)
  81.         (funcall fn xp args args))))))
  82.  
  83.  
  84. ;;; Try to detect format strings without fancy directives, that can be 
  85. ;;; written with a call to  write-string.
  86. ;;; Can do simple transformations e.g. ~% => newline, ~~ => ~, etc.
  87.  
  88. (define (xp.simple-format-string? s start end)
  89.   (let ((twiddle  (string-position #\~ s start end)))
  90.     (if (not twiddle)
  91.     (if (eqv? start 0)
  92.         s
  93.         (substring s start end))
  94.     (let ((char    (string-ref s (1+ twiddle))))
  95.       (cond ((eqv? char #\%)
  96.          (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
  97.            (if tail
  98.                (string-append (substring s start twiddle)
  99.                       (string #\newline)
  100.                       tail)
  101.                '#f)))
  102.         ((eqv? char #\~)
  103.          (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
  104.            (if tail
  105.                (string-append (substring s start (1+ twiddle))
  106.                       tail)
  107.                '#f)))
  108.         ((eqv? char #\newline)
  109.          (let ((tail (xp.simple-format-string?
  110.                      s
  111.                  (xp.skip-whitespace s (+ twiddle 2) end)
  112.                  end)))
  113.            (if tail
  114.                (string-append (substring s start twiddle)
  115.                       tail)
  116.                '#f)))
  117.         (else
  118.          '#f))))))
  119.  
  120. (define (warning string-or-fn . args)
  121.   (internal-warning (apply (function format) '#f string-or-fn args)))
  122.  
  123. (define (error string-or-fn . args)
  124.   (internal-error (apply (function format) '#f string-or-fn args)))
  125.  
  126.  
  127. ;;;=====================================================================
  128. ;;; Compiled format
  129. ;;;=====================================================================
  130.  
  131. ;;; Note that compiled format strings always print through xp streams even if
  132. ;;; they don't have any xp directives in them.  As a result, the compiled code
  133. ;;; can depend on the fact that the stream being operated on is an xp
  134. ;;; stream not an ordinary one.
  135.  
  136.  
  137. ;;; Parse a format string, returning a function to do the printing.
  138. ;;; The function is called with three arguments
  139. ;;;    * the xp stream
  140. ;;;    * the original argument list
  141. ;;;    * the argument list tail
  142. ;;; It should return the list of leftover, unprocessed arguments.
  143.  
  144. (define (xp.parse-format-string string start end)
  145.   (cond ((eqv? start end)
  146.      (function xp.format-finish))
  147.     ((eqv? (string-ref string start) #\~)
  148.      (xp.parse-format-string-dispatch string start end))
  149.     (else
  150.      (let* ((next       (or (string-position #\~ string start end) end))
  151.         (literal    (substring string start next))
  152.         (count      (- next start))
  153.         (continue   (xp.parse-format-string string next end))
  154.         (newline?   (string-position #\newline literal 0 count)))
  155.        (if newline?
  156.            (lambda (xp args tail)
  157.          (xp.write-string+ literal xp 0 count)
  158.          (funcall continue xp args tail))
  159.            (lambda (xp args tail)
  160.          (xp.write-string++ literal xp 0 count)
  161.          (funcall continue xp args tail)))))
  162.     ))
  163.  
  164. (define (xp.format-finish xp args tail)
  165.   (declare (ignore xp args))
  166.   tail)
  167.  
  168.  
  169. ;;; Functions for handling individual format specifiers are installed
  170. ;;; in this table.  They are called with these arguments:
  171. ;;; * the format string
  172. ;;; * the index of the next character
  173. ;;; * the index of the end of the format string
  174. ;;; * the list of parameters for the format specification
  175. ;;; * a boolean indicating whether the colon modifier was present
  176. ;;; * a boolean indicating whether the atsign modifier was present
  177. ;;; The handler is responsible for calling xp.parse-format-string to parse 
  178. ;;; the rest of the format string, and returning a function.  (This has
  179. ;;; to be done by the individual handlers because some of them need to
  180. ;;; scan the format string for matching delimiters, etc.)
  181.  
  182. ;;; *** This probably isn't right, we assume characters can be compared
  183. ;;; *** with EQ? and used as table keys.
  184.  
  185. (define xp.fn-table (make-table))
  186.  
  187. (define (define-format char function)
  188.   (setf (table-entry xp.fn-table (char-upcase char)) function)
  189.   (setf (table-entry xp.fn-table (char-downcase char)) function))
  190.  
  191. ;;; Parse a ~ sequence from the format string and dispatch to the
  192. ;;; appropriate handler.  
  193.  
  194. (define (xp.parse-format-string-dispatch string start end)
  195.   (multiple-value-bind (next params colon? atsign? char)
  196.       (xp.parse-format-descriptor string start end)
  197.     (let ((fn  (table-entry xp.fn-table char)))
  198.       (if fn
  199.       (funcall fn string next end params colon? atsign?)
  200.       (error "Unrecognized format escape ~~~a." char)))))
  201.  
  202. (define (xp.parse-format-descriptor string start end)
  203.   (multiple-value-bind (params start)
  204.       (xp.parse-format-parameters string start end)
  205.     (let ((colon?    '#f)
  206.       (atsign?   '#f)
  207.       (char      '#f))
  208.       (block parse-format-descriptor
  209.     (do ()
  210.         ((xp.check-for-incomplete-format-string string start end))
  211.         (setf char (string-ref string start))
  212.         (incf start)
  213.         (cond ((eqv? char #\:)
  214.            (setf colon? '#t))
  215.           ((eqv? char #\@)
  216.            (setf atsign? '#t))
  217.           (else
  218.            (return-from parse-format-descriptor
  219.              (values start params colon? atsign? char)))
  220.         ))))))
  221.  
  222.  
  223. ;;; *** The stuff for V and # format parameters is disabled because
  224. ;;; *** it makes the handler functions hairier.  It's rarely used anyway,
  225. ;;; *** and you can get the same effect by consing up a format string
  226. ;;; *** on the fly if you really need to.
  227.  
  228. (define (xp.parse-format-parameters string start end)
  229.   (let ((params  '())
  230.     (char    '#f))
  231.     (incf start)  ; skip ~
  232.     (block parse-format-parameters
  233.       (do ()
  234.       ((xp.check-for-incomplete-format-string string start end))
  235.       (setf char (string-ref string start))
  236.       (cond ((char-numeric? char)
  237.          (multiple-value-bind (next value)
  238.              (xp.parse-format-number string start end 0)
  239.            (setf start next)
  240.            (push value params)))
  241.         ((eqv? char #\')
  242.          (push (string-ref string (1+ start)) params)
  243.          (setf start (+ start 2)))
  244.         ((or (eqv? char #\v) (eqv? char #\V))
  245.          (error "V format parameter not supported.")  ;***
  246.          (push 'value params)
  247.          (setf start (+ start 1)))
  248.         ((eqv? char #\#)
  249.          (error "# format parameter not supported.")  ;***
  250.          (push 'count params)
  251.          (setf start (+ start 1)))
  252.         ((eqv? char #\,)
  253.          (push '#f params))
  254.         (else
  255.          (return-from parse-format-parameters
  256.            (values (nreverse params) start))))
  257.       (if (eqv? (string-ref string start) #\,)
  258.           (incf start))))))
  259.  
  260. (define (xp.parse-format-number string start end value)
  261.   (xp.check-for-incomplete-format-string string start end)
  262.   (let* ((char    (string-ref string start))
  263.      (weight  (string-position char "0123456789" 0 10)))
  264.     (if weight
  265.     (xp.parse-format-number string (1+ start) end (+ (* value 10) weight))
  266.     (values start value))))
  267.  
  268. (define (xp.check-for-incomplete-format-string string start end)
  269.   (if (eqv? start end)
  270.       (error "Incomplete format string ~s." string)
  271.       '#f))
  272.  
  273.  
  274. ;;; *** All of these format handlers probably ought to do more checking
  275. ;;; *** for the right number of parameters and not having colon? and
  276. ;;; *** atsign? supplied when they are not allowed.
  277.  
  278. ;;; ~A and ~S are the basic format directives.
  279.  
  280. (define (xp.format-a string start end params colon? atsign?)
  281.   (xp.format-a-s-helper string start end params colon? atsign? '#f))
  282. (define-format #\a (function xp.format-a))
  283.  
  284. (define (xp.format-s string start end params colon? atsign?)
  285.   (xp.format-a-s-helper string start end params colon? atsign? '#t))
  286. (define-format #\s (function xp.format-s))
  287.  
  288. (define (xp.format-a-s-helper string start end params colon? atsign? escape?)
  289.   (declare (ignore colon? atsign?))  ;***
  290.   (let ((continuation  (xp.parse-format-string string start end)))
  291.     (if (null? params)
  292.     ;; Do the simple, common case.
  293.     (lambda (xp args tail)
  294.       (dynamic-let ((*print-escape*   escape?))
  295.         (xp.write+ (car tail) xp))
  296.       (funcall continuation xp args (cdr tail)))
  297.     ;; Do the hard case.
  298.     (let* ((mincol   (or (and (not (null? params)) (pop params)) 0))
  299.            (colinc   (or (and (not (null? params)) (pop params)) 1))
  300.            (minpad   (or (and (not (null? params)) (pop params)) 0))
  301.            (padchar  (or (and (not (null? params)) (pop params)) #\space)))
  302.       (declare (ignore mincol colinc minpad padchar))  ;***
  303. ;;; *** I'm confused.  It seems like we have to print this to a string
  304. ;;; *** and then write the string to the XP stream along with the padding
  305. ;;; *** But won't switching to a new stream mess up circularity detection, 
  306. ;;; *** indentation, etc?
  307.       (error "Unimplemented format option ~s!" string))
  308.       )))
  309.  
  310.  
  311. ;;; ~W -> write
  312.  
  313. (define (xp.format-w string start end params colon? atsign?)
  314.   (declare (ignore params))
  315.   (let ((continuation  (xp.parse-format-string string start end)))
  316.     (cond ((and (not colon?) (not atsign?))
  317.        (lambda (xp args tail)
  318.          (xp.write+ (car tail) xp)
  319.          (funcall continuation xp args (cdr tail))))
  320.       ((and colon? (not atsign?))
  321.        (lambda (xp args tail)
  322.          (dynamic-let ((*print-pretty*  '#t))
  323.            (xp.write+ (car tail) xp))
  324.          (funcall continuation xp args (cdr tail))))
  325.       ((and (not colon?) atsign?)
  326.        (lambda (xp args tail)
  327.          (dynamic-let ((*print-level*  '#f)
  328.                (*print-length* '#f))
  329.            (xp.write+ (car tail) xp))
  330.          (funcall continuation xp args (cdr tail))))
  331.       ((and colon? atsign?)
  332.        (lambda (xp args tail)
  333.          (dynamic-let ((*print-level*  '#f)
  334.                (*print-length* '#f)
  335.                (*print-pretty* '#t))
  336.            (xp.write+ (car tail) xp))
  337.          (funcall continuation xp args (cdr tail))))
  338.       )))
  339. (define-format #\w (function xp.format-w))
  340.  
  341.  
  342. ;;; Here are the directives for printing integers, ~D and friends.
  343.  
  344. (define (xp.format-d string start end params colon? atsign?)
  345.   (xp.format-d-b-o-x-helper string start end params colon? atsign? 10))
  346. (define-format #\d (function xp.format-d))
  347.  
  348. (define (xp.format-b string start end params colon? atsign?)
  349.   (xp.format-d-b-o-x-helper string start end params colon? atsign? 2))
  350. (define-format #\b (function xp.format-b))
  351.  
  352. (define (xp.format-o string start end params colon? atsign?)
  353.   (xp.format-d-b-o-x-helper string start end params colon? atsign? 8))
  354. (define-format #\o (function xp.format-o))
  355.  
  356. (define (xp.format-x string start end params colon? atsign?)
  357.   (xp.format-d-b-o-x-helper string start end params colon? atsign? 16))
  358. (define-format #\x (function xp.format-x))
  359.  
  360. (define (xp.format-d-b-o-x-helper string start end params colon? atsign? radix)
  361.   (let ((continuation  (xp.parse-format-string string start end)))
  362.     (if (and (null? params) (not colon?) (not atsign?))
  363.     ;; Do the simple, common case.
  364.     (lambda (xp args tail)
  365.       (dynamic-let ((*print-escape*  '#f)
  366.             (*print-radix*   '#f)
  367.             (*print-base*    radix))
  368.         (xp.write+ (car tail) xp))
  369.       (funcall continuation xp args (cdr tail)))
  370.     ;; Do the hard case.
  371.     (let* ((mincol    (or (and (not (null? params)) (pop params)) 0))
  372.            (padchar   (or (and (not (null? params)) (pop params)) #\space))
  373.            (commachar (or (and (not (null? params)) (pop params)) #\,))
  374.            (commaint  (or (and (not (null? params)) (pop params)) 3)))
  375.       (declare (ignore mincol padchar commachar commaint))  ;***
  376.       ;; *** I'm too lazy to do this right now.
  377.       (error "Unimplemented format option ~s!" string)))))
  378.  
  379.  
  380. (define (xp.format-r string start end params colon? atsign?)
  381.   (if (not (null? params))
  382.       (xp.format-d-b-o-x-helper string start end (cdr params)
  383.                  colon? atsign? (car params))
  384.       ;; *** The colon? and atsign? modifiers do weird things like
  385.       ;; *** printing roman numerals.  I'm too lazy to do this until/unless
  386.       ;; *** we have a real need for it.
  387.       (error "Unimplemented format option ~s!" string)))
  388. (define-format #\r (function xp.format-r))
  389.  
  390.  
  391. ;;; ~P -> plurals
  392.  
  393. (define (xp.format-p string start end params colon? atsign?)
  394.   (declare (ignore params))
  395.   (let ((continuation  (xp.parse-format-string string start end)))
  396.     (cond ((and (not colon?) (not atsign?))
  397.        (lambda (xp args tail)
  398.          (if (not (eqv? (car tail) 1))
  399.          (xp.write-char++ #\s xp))
  400.          (funcall continuation xp args (cdr tail))))
  401.       ((and colon? (not atsign?))
  402.        (lambda (xp args tail)
  403.          (setf tail (xp.back-up 1 args tail))
  404.          (if (not (eqv? (car tail) 1))
  405.          (xp.write-char++ #\s xp))
  406.          (funcall continuation xp args (cdr tail))))
  407.       ((and (not colon?) atsign?)
  408.        (lambda (xp args tail)
  409.          (if (eqv? (car tail) 1)
  410.          (xp.write-char++ #\y xp)
  411.          (begin
  412.            (xp.write-char++ #\i xp)
  413.            (xp.write-char++ #\e xp)
  414.            (xp.write-char++ #\s xp)))
  415.          (funcall continuation xp args (cdr tail))))
  416.       ((and colon? atsign?)
  417.        (lambda (xp args tail)
  418.          (setf tail (xp.back-up 1 args tail))
  419.          (if (eqv? (car tail) 1)
  420.          (xp.write-char++ #\y xp)
  421.          (begin
  422.            (xp.write-char++ #\i xp)
  423.            (xp.write-char++ #\e xp)
  424.            (xp.write-char++ #\s xp)))
  425.          (funcall continuation xp args (cdr tail)))))))
  426. (define-format #\p (function xp.format-p))
  427.  
  428.  
  429. ;;; ~C -> character
  430.  
  431. (define (xp.format-c string start end params colon? atsign?)
  432.   (declare (ignore params))
  433.   (let ((continuation  (xp.parse-format-string string start end)))
  434.     (cond ((and (not colon?) (not atsign?))
  435.        (lambda (xp args tail)
  436.          (xp.write-char++ (car tail) xp)
  437.          (funcall continuation xp args (cdr tail))))
  438.       ((and (not colon?) atsign?)
  439.        (lambda (xp args tail)
  440.          (dynamic-let ((*print-escape*  '#t))
  441.            (xp.write+ (car tail) xp)
  442.            (funcall continuation xp args (cdr tail)))))
  443.       (else
  444.        ;; *** I don't know how to get at the character names.
  445.        (error "Unimplemented format option ~s!" string)))))
  446. (define-format #\c (function xp.format-c))
  447.  
  448.  
  449.  
  450. ;;; Newline directives, ~% and ~&
  451.  
  452. (define (xp.format-percent string start end params colon? atsign?)
  453.   (xp.format-newline-helper string start end params colon? atsign?
  454.              'unconditional))
  455. (define-format #\% (function xp.format-percent))
  456.  
  457. (define (xp.format-ampersand string start end params colon? atsign?)
  458.   (xp.format-newline-helper string start end params colon? atsign?
  459.              'fresh))
  460. (define-format #\& (function xp.format-ampersand))
  461.  
  462. (define (xp.format-newline-helper string start end params colon? atsign? kind)
  463.   (declare (ignore colon? atsign?))
  464.   (let ((continuation (xp.parse-format-string string start end))
  465.     (n            (or (and (not (null? params)) (pop params)) 1)))
  466.     (if (eqv? n 1)
  467.     (lambda (xp args tail)
  468.       (xp.pprint-newline+ kind xp)
  469.       (funcall continuation xp args tail))
  470.     (lambda (xp args tail)
  471.       (xp.pprint-newline+ kind xp)
  472.       (dotimes (i (1- n))
  473.         (xp.pprint-newline+ 'unconditional xp))
  474.       (funcall continuation xp args tail))
  475.       )))
  476.  
  477.  
  478. ;;; ~_, Conditional newline
  479.  
  480. (define (xp.format-underbar string start end params colon? atsign?)
  481.   (declare (ignore params))
  482.   (let ((continuation  (xp.parse-format-string string start end))
  483.     (kind          (if colon?
  484.                (if atsign? 'mandatory 'fill)
  485.                (if atsign? 'miser 'linear))))
  486.     (lambda (xp args tail)
  487.       (xp.pprint-newline+ kind xp)
  488.       (funcall continuation xp args tail))))
  489. (define-format #\_ (function xp.format-underbar))
  490.  
  491.  
  492. ;;; Random character printing directives, ~| and ~~
  493.  
  494. ;;; *** commented out because #\page is not standard scheme
  495. ; (define (xp.format-bar string start end params colon? atsign?)
  496. ;  (xp.format-char-helper string start end params colon? atsign? #\page))
  497. ; (define-format #\| (function xp.format-bar))
  498.  
  499. (define (xp.format-twiddle string start end params colon? atsign?)
  500.   (xp.format-char-helper string start end params colon? atsign? #\~))
  501. (define-format #\~ (function xp.format-twiddle))
  502.  
  503. (define (xp.format-char-helper string start end params colon? atsign? char)
  504.   (declare (ignore colon? atsign?))
  505.   (let ((continuation  (xp.parse-format-string string start end))
  506.     (n             (or (and (not (null? params)) (pop params)) 1)))
  507.     (if (eqv? n 1)
  508.     (lambda (xp args tail)
  509.       (xp.write-char++ char xp)
  510.       (funcall continuation xp args tail))
  511.     (lambda (xp args tail)
  512.       (dotimes (i n)
  513.         (xp.write-char++ char xp))
  514.       (funcall continuation xp args tail)))))
  515.  
  516.  
  517.  
  518. ;;; ~<newline> directive (ignore whitespace in format string)
  519.  
  520. (define (xp.format-newline string start end params colon? atsign?)
  521.   (declare (ignore params))
  522.   (let ((newline?   '#f)
  523.     (skip?      '#f))
  524.     (cond ((and (not colon?) (not atsign?))  ; skip both newline and whitespace
  525.        (setf skip? '#t))
  526.       ((and colon? (not atsign?)))  ; skip newline, leave whitespace
  527.       ((and (not colon?) atsign?)   ; do newline, skip whitespace
  528.        (setf newline? '#t)
  529.        (setf skip? '#t))
  530.       (else
  531.        (error "~:@<newline> not allowed.")))
  532.     (if skip?
  533.     (setf start (xp.skip-whitespace string start end)))
  534.     (let ((continuation  (xp.parse-format-string string start end)))
  535.       (if newline?
  536.       (lambda (xp args tail)
  537.         (xp.pprint-newline+ 'unconditional xp)
  538.         (funcall continuation xp args tail))
  539.       continuation))))
  540. (define-format #\newline (function xp.format-newline))
  541.  
  542. (define (xp.skip-whitespace string start end)
  543.   (if (eqv? start end)
  544.       start
  545.       (let ((char  (string-ref string start)))
  546.     (if (and (char-whitespace? char)
  547.          (not (eqv? char #\newline)))
  548.         (xp.skip-whitespace string (1+ start) end)
  549.         start))))
  550.  
  551.  
  552.  
  553. ;;; ~T -> tab
  554.  
  555. (define (xp.format-t string start end params colon? atsign?)
  556.   (let* ((continuation  (xp.parse-format-string string start end))
  557.      (colnum        (or (and (not (null? params)) (pop params)) 1))
  558.      (colinc        (or (and (not (null? params)) (pop params)) 1))
  559.      (kind          (if colon?
  560.                 (if atsign? 'section-relative 'section)
  561.                 (if atsign? 'line-relative 'line))))
  562.     (lambda (xp args tail)
  563.       (xp.pprint-tab+ kind colnum colinc xp)
  564.       (funcall continuation xp args tail))))
  565. (define-format #\t (function xp.format-t))
  566.  
  567.  
  568. ;;; ~I -> indent
  569.  
  570. (define (xp.format-i string start end params colon? atsign?)
  571.   (declare (ignore atsign?))
  572.   (let ((continuation  (xp.parse-format-string string start end))
  573.     (kind          (if colon? 'current 'block))
  574.     (n             (or (and (not (null? params)) (pop params)) 0)))
  575.     (lambda (xp args tail)
  576.       (pprint-indent kind n)
  577.       (funcall continuation xp args tail))))
  578. (define-format #\i (function xp.format-i))
  579.  
  580.  
  581. ;;; ~* -> skip or back up over arguments
  582.  
  583. (define (xp.format-star string start end params colon? atsign?)
  584.   (let ((continuation  (xp.parse-format-string string start end))
  585.     (n             (or (and (not (null? params)) (pop params)) 1)))
  586.     (cond ((and (not colon?) (not atsign?))
  587.        (lambda (xp args tail)
  588.          (funcall continuation xp args (list-tail tail n))))
  589.       ((and colon? (not atsign?))
  590.        (lambda (xp args tail)
  591.          (funcall continuation xp args (xp.back-up n args tail))))
  592.       ((and (not colon?) atsign?)
  593.        (lambda (xp args tail)
  594.          (declare (ignore tail))
  595.          (funcall continuation xp args (list-tail args n))))
  596.       (else
  597.        (error "~:@* not allowed.")))))
  598. (define-format #\* (function xp.format-star))
  599.  
  600. (define (xp.back-up n head tail)
  601.   (if (eq? (list-tail head n) tail)
  602.       head
  603.       (xp.back-up n (cdr head) tail)))
  604.  
  605.  
  606. ;;; ~? -> indirection
  607. ;;; Normally uses two arguments, a string and a list.
  608. ;;; With @, only uses a string, takes arguments from the tail.
  609.  
  610. (define (xp.format-question string start end params colon? atsign?)
  611.   (declare (ignore params colon?))
  612.   (let ((continuation  (xp.parse-format-string string start end)))
  613.     (if atsign?
  614.     (lambda (xp args tail)
  615.       (setf tail (apply (function format) xp (car tail) (cdr tail)))
  616.       (funcall continuation xp args tail))
  617.     (lambda (xp args tail)
  618.       (apply (function format) xp (car tail) (cadr tail))
  619.       (funcall continuation xp args (cddr tail))))))
  620. (define-format #\? (function xp.format-question))
  621.  
  622.  
  623. ;;; ~(...~) -> case conversion.
  624.  
  625. (define *xp.format-paren-next* '#f)
  626.  
  627. (define (xp.format-paren string start end params colon? atsign?)
  628.   (declare (ignore params))
  629.   (let* ((handler      (dynamic-let ((*xp.format-paren-next* '#t))
  630.              (let ((result (xp.parse-format-string
  631.                        string start end)))
  632.                (if (eq? (dynamic *xp.format-paren-next*) '#t)
  633.                    (error "~( directive has no matching ~)."))
  634.                (setf start (dynamic *xp.format-paren-next*))
  635.                result)))
  636.      (continuation (xp.parse-format-string string start end))
  637.      (mode         (if colon?
  638.                (if atsign? 'up 'cap1)
  639.                (if atsign? 'cap0 'down))))
  640.     (lambda (xp args tail)
  641.       (xp.push-char-mode xp mode)
  642.       (setf tail (funcall handler xp args tail))
  643.       (xp.pop-char-mode xp)
  644.       (funcall continuation xp args tail))))
  645. (define-format #\( (function xp.format-paren))
  646.  
  647. (define (xp.format-paren-end string start end params colon? atsign?)
  648.   (declare (ignore string end params colon? atsign?))
  649.   (if (not (dynamic *xp.format-paren-next*))
  650.       (error "~) directive has no matching ~(."))
  651.   (setf (dynamic *xp.format-paren-next*) start)
  652.   (function xp.format-finish))
  653. (define-format #\) (function xp.format-paren-end))
  654.  
  655. ;;; ~F      -> fixed-width      *** unimplemented
  656. ;;; ~E      -> e-notation       *** unimplemented
  657. ;;; ~G      -> general float    *** unimplemented
  658. ;;; ~$      -> dollars float    *** unimplemented
  659. ;;; ~[...~] -> conditional      *** unimplemented
  660. ;;; ~{...~} -> iteration        *** unimplemented
  661. ;;; ~<...~> -> justification    *** unimplemented
  662. ;;; ~;      -> clause seperator *** unimplemented
  663. ;;; ~^      -> up and out       *** unimplemented
  664. ;;; ~/.../  -> hook             *** unimplemented
  665.  
  666. (define (xp.unimplemented-format string start end params colon? atsign?)
  667.   (declare (ignore start end params colon? atsign?))
  668.   (error "Unimplemented format directive in ~s." string))
  669.  
  670. (define-format #\f (function xp.unimplemented-format))
  671. (define-format #\e (function xp.unimplemented-format))
  672. (define-format #\g (function xp.unimplemented-format))
  673. (define-format #\$ (function xp.unimplemented-format))
  674. (define-format #\[ (function xp.unimplemented-format))
  675. (define-format #\] (function xp.unimplemented-format))
  676. (define-format #\{ (function xp.unimplemented-format))
  677. (define-format #\} (function xp.unimplemented-format))
  678. (define-format #\< (function xp.unimplemented-format))
  679. (define-format #\> (function xp.unimplemented-format))
  680. (define-format #\; (function xp.unimplemented-format))
  681. (define-format #\^ (function xp.unimplemented-format))
  682. (define-format #\/ (function xp.unimplemented-format))
  683.  
  684.